perm filename DREDIT.OLD[DRW,LCS] blob
sn#396826 filedate 1978-11-17 generic text, type T, neo UTF8
SUBROUTINE DREDIT
COMMON/ED/K,NEXT,NN,NX,NY,J
COMMON /RZ/RSZ,IPLT,RJB,CENTR
COMMON /RC/MCLEF(400),IST(4000)
COMMON/ZN/SCLEF(400,2),N
COMMON/LL/LL
COMMON/JJJ/JJJ
EQUIVALENCE(M,SCLEF(1,2)),(KK,SCLEF(1,1))
NEXTX=NEXT-1
J=MCLEF(1)
20 IF(K.EQ.'D')GO TO 1
C MOVE CURSOR TO INSERT POINT, TYPE CR.
9 FORMAT(' SET POINT ',$)
IF(JJJ.EQ.-2)GO TO 131
C FOR CONTINUING RELATIVE CHANGE
CC IF(JJJ.EQ.0)JJK=0
5 TYPE 9
ACCEPT 3,L
IF(L.EQ.'B'.OR.L.EQ.'N')RETURN
C N OR B=BACKUP, J=INSERT OR ALTER TO JUMP, C=ALTER JUMP TO CONT.
IF(L.EQ.' ')GO TO 12
IF(L.NE.'F')GO TO 50
MCLEF(NEXT-1)=MCLEF(NEXT-1)+200000000
RETURN
C ABOVE SET NEW FILL POINT.
50 REREAD 33,ML,MLA
IF(JJJ)JJJ=-2
C TO SET POINT BY NUM(NOT FOR FILLER) NOT NOW IN!
131 IF(M.GE.0)CALL UNPACK(NEXTX,NX,NY,MCLEF)
C FOR RELATIVE POS. CHANGE
X=NX+ML
Y=NY+MLA
GO TO 13
12 CALL RDCUR(NX,NY)
130 X=STPT(FLOAT(NX),RJB)
Y=STPT(FLOAT(NY),CENTR)
13 NX=GTPT(X,RJB)
NY=GTPT(Y,CENTR)
CALL SETCUR(NX,NY,0)
IF(K.EQ.0)GO TO 14
NT=NEXT
L=NT
40 FORMAT(' POINT OK? (Y,N,B,J,F OR C) ',$)
C Y=YES,N=NO,B=BACKUP,J=JUMP,F=START FILL,C=CONTINUE(NULLIFY JUMP)
TYPE 4,L,X,Y
TYPE 40
ACCEPT 3,L
IF(L.EQ.'B')RETURN
IF(L.EQ.'N')GO TO 5
IF(K.NE.'A')GO TO 8
C WHAT IS ABOVE FOR?????
NT=NEXTX
GO TO 7
11 FORMAT(I3,')',2I6,1X$)
CC8 TYPE 19
CC ACCEPT 3,L
CC IF(L.EQ.'B')RETURN
8 A=X
B=Y
K=0
GO TO 12
C NOW ASSUMES → IF NO ← POINT FOUND
14 IF(NX.EQ.SCLEF(NT-2,1).AND.NY.EQ.SCLEF(NT-2,2))NT=NT-1
15 X=A
Y=B
J=J+1
DO 6 L=J,NT+1,-1
6 MCLEF(L)=MCLEF(L-1)
7 LL=0
NX=X
NY=Y
IF(MCLEF(NT).GT.100000000.AND.L.NE.'C')LL=(MCLEF(NT)/100000000)*
1 100000000
IF(L.EQ.'J')LL=100000000
IF(L.EQ.'F')LL=200000000
K=MCLEF(NT)
CALL REPACK(NT,NX,NY,MCLEF)
GO TO 100
CC19 FORMAT(' OTHER POINT? ',$)
3 FORMAT(A1)
33 FORMAT(2I)
4 FORMAT(I4,')',2F6.0)
C NT IS FOR INSERTS
1 IF(J-NEXT)RETURN
DO 10 L=NEXT,J+1
IF(L.EQ.'F')LL=200000000
10 MCLEF(L-1)=MCLEF(L)
J=J-1
100 MCLEF(1)=J
KK=0
IF(MCLEF(2).LT.100000000)MCLEF(2)=MCLEF(2)+100000000
CALL DPYSET(1,IST,4000)
CALL DPYBRT(5)
KK=1
CALL RDRAW(2,MCLEF(1),MCLEF)
CALL DPYOUT(1)
CC RETURN
CC2 CALL RDCUR(NX,NY)
END
C*******************************************************
FUNCTION STPT(A,X)
COMMON /RZ/RSZ,IPLT,RJB,CENTR
R=.5
Q=A/RSZ-X
IF(Q)R=-R
STPT=IFIX(Q+R)
RETURN
END
FUNCTION GTPT(A,X)
COMMON /RZ/RSZ,IPLT,RJB,CENTR
GTPT=(A+X)*RSZ
END
SUBROUTINE SMOOTH(JQ)
COMMON/ED/KX,NEXT,NN,NX,NY,J/LL/L
COMMON /RC/MCLEF(400),IST(4000)
COMMON /RZ/RSZ,IPLT,RJB,CENTR
COMMON /FL/IC,NJ,NQ,RZ,IXRX,XGP,RXGP
DIMENSION BUF2(700),SX(512),SY(512)
COMMON/NFF/NE(513)
DATA INC/10/
RR=RSZ
CC IF(IPLT.EQ.0)RR=RR*1.7
COMMON X(100),Y(100),N,X1(512),Y1(512),S(100),K
IF(IPLT.EQ.0.AND.JQ.EQ.0)CALL DPYSET(1,IST,4000)
IF(JQ.NE.' ')CALL HYDPOG(1)
JL=0
NOFIL=-1
IF(JQ.EQ.0)NOFIL=0
100 JY=2
IF(IPLT.EQ.0)CALL DPYSET(3,BUF2,700)
J=MCLEF(1)
7 JX=J
8 KX=0
DO 1 K=JY,J
CALL UNPACK(K,JA,JB,MCLEF)
IF(L.GE.100000000.AND.K.GT.JY)GO TO 6
C JUMP WHEN INVIS. VECT.
KX=KX+1
X(KX)=JA+RJB
1 Y(KX)=JB+CENTR
9 X(KX+1)=999.
4 N=KX
CALL SS
JL=JL+1
JK=JL
SX(JL)=X1(1)*RR
SY(JL)=Y1(1)*RR
CALL LINES(X1(1),Y1(1),3)
DO 5 K=2,512,INC
JL=JL+1
SX(JL)=X1(K)*RR
SY(JL)=Y1(K)*RR
NE(JL)=0
5 CALL LINES(X1(K),Y1(K),2)
IF(SX(JL).NE.SX(JK))SX(JK)=SX(JL)
IF(SY(JL).NE.SY(JK))SY(JK)=SY(JL)
NE(JK)=3
C FOR INVIS. VECTOR
IF(IPLT.EQ.0)CALL DPYOUT(3)
10 IF(JX.NE.J)GO TO 7
CALL SETPOG(1)
IF(NOFIL)RETURN
200 NE(1)=JL
CALL FILLQ(SX,SY,NE)
RETURN
6 JY=K
JX=JY
GO TO 9
END
SUBROUTINE EDTYP(K,X,Y,JJJ)
TYPE 57
ACCEPT 1,K,X,Y
IF(K.NE.' ')JJJ=0
IF(K.EQ.':'.OR.JJJ)GO TO 2
C TYPE "A" OR ":" TO ALTER
IF(K.NE.'G')RETURN
JJJ=-1
2 K='A'
57 FORMAT(' TYPE D, A, I OR X ',$)
C M N1, N2 = MOVE SEGS N1 THROUGH N2.
1 FORMAT(A1,2F)
END
SUBROUTINE ITYP
COMMON /RZ/RSZ,IPLT,RJB,CENTR
COMMON/ED/K,NEXT,NN,NX,NY,J
A=STPT(FLOAT(NX),RJB)
B=STPT(FLOAT(NY),CENTR)
TYPE 1,NN,A,B
1 FORMAT(I4,')',2F6.0)
END
SUBROUTINE FILLQ(Q,R,N)
DIMENSION Q(1),R(1),N(1)
COMMON /RZ/RSZ,IPLT,RJB,CENTR
M=6
IF(IPLT)M=1
1 RZ=RSZ
RSZ=1.0
CC IF(IPLT.EQ.0)RSZ=1./1.7
CALL FILLER(Q,R,N,M)
RSZ=RZ
IF(IPLT.GE.0)CALL DPYOUT(1)
END
SUBROUTINE SAVE(M)
DIMENSION M(1)
J=7
L=8
DO 12 K=1,M(1),8
IF(K+J.LT.M(1))GO TO 12
J=M(1)-K
L=J+1
12 WRITE(1,11)L,(M(NM),NM=K,K+J)
RETURN
11 FORMAT(' 9999',I3,8I10)
END